;;########################################################################
;; tranobj1.lsp
;; contains code to implement prototype transformation objects
;; Copyright (c) 1991-2002 by Forrest W. Young
;; 

;;########################################################################

;;entry point for this code: (show-datasheet)

;;------------------------------------------------------------------------
;;transformation object proto
;;------------------------------------------------------------------------

(defproto transf-object-proto () () mv-model-object-proto)

(defmeth transf-object-proto :isnew 
  (tool-id data-obj title name dialog &optional (ok-types '(numeric)))
"Args: tool-id data-obj title name dialog &optional (ok-types '(numeric))"
  (setf *show-info* nil)
  (send self :transf-obj? t)
  (send self :statistical-object-type "transf")
  (send self :model-abbrev name)
  (setf tool-id name)
  (send self :name name)
  ;(send self :new-object)
  (setf name (strcat name "!" (send data-obj :name)))
  (call-next-method tool-id data-obj title name dialog ok-types)
  (send self :statistical-object-type "transf")
  (send self :set-current-data-variables)
  (setf *show-info* t)
  )

(defmeth transf-object-proto :statistical-object-type (&optional (logical nil set))
;written this way to prevent changing slot to invalid value
    (setf (slot-value 'statistical-object-type) "transf")
    (slot-value 'statistical-object-type))

(defmeth transf-object-proto :new-object () (setct self))

(defun set-current-transformation (object) (setct  object))

(defun setct (&optional (object nil object?))
  (cond 
    ((and (not object) object?)
     (set-current-data-variables nil)
     nil)
    ((not object) *current-object*)
    (object
     ;(let* ((old-selected-icon-number (send *workmap* :selected-icon))
     ;       (old-selected-icon-object (send *workmap* :selected-icon-object))
     ;       (new-selected-icon-number (send object :icon-number))
     ;       )
     ;  (send *workmap* :previously-selected-icon old-selected-icon-number)
     ;  (send old-selected-icon-object :turn-title-off)
     ;  (send old-selected-icon-object :draw-title)
     ;  (send *workmap* :selected-icon new-selected-icon-number)
       (setf current-transf  object)
       (setf current-object object)
       (setf *current-transf* object)
       (setf *current-object* object)
       (setf *co* object)
       (setf *ct* object)
       (setf @ object)
       ;fwy removed next three lines 09-05-02
       ;(send (send *vista* :var-window-object) :clear)
      ; (send (send *vista* :obs-window-object) :clear)
       ;(send @ :set-menu&tool-states "disabled")
       object;)
     )))

(defmeth transf-object-proto :set-current-data-variables ()
  (setct self)
  (unless (send self :$)
          (when (send self :name)
                (set (intern (string-upcase (send self :name))) self ))
          (when (send self :full-name)
                (set (intern (string-upcase (send self :full-name))) self))
          (when (send self :proper-name)
                (set (intern (string-upcase (send self :proper-name))) self ))
          (when (send self :elipsis-name)
                (set (intern (string-upcase (send self :elipsis-name))) self ))
          (send self :$ self)
          ))

(defmeth transf-object-proto :make-names (&optional name extension)
  (unless name (setf name (send self :name)))
  (unless name (fatal-message "undefined name"))
  (send self :name name)
  (send self :extension "trn")
 ; (send self :proper-name (proper-name name "trn"))
 ; (send self :full-name (send self :proper-name))
 ; (send self :elipsis-name (elipsis-name (send self :proper-name)))
  (let* ((name-list (make-names name "trn")))
    (send self :name (first name-list))
    (send self :full-name (second name-list))
    (send self :proper-name (third name-list))
    (send self :elipsis-name (fourth name-list))
  ))
  

(defmeth transf-object-proto :make-object-id ()
  (format nil "#<Object: ~a, StatObj:~a>"
          (send self :full-name)
          (send self :vistatype)))

(defmeth transf-object-proto :make-object-id () (call-next-method))
    
(defmeth transf-object-proto :subject-id  (&optional (stream *standard-output*))
  (send (send self :data-object) :object-id stream))

(defmeth transf-object-proto :make-vistatype ()
  (format nil "~a; ~aTrnsf; ~,4d seconds" 
          (send self :proper-name)
          (send self :model-abbrev)
          (fuzz (send self :elapsed-time) 3)
          ))
    
(defmeth transf-object-proto :print (&optional (stream *standard-output*))
  (format stream "~a" (trimmed-name (send self :proper-name))))

(defmeth transf-object-proto :info (&optional (stream *standard-output*) 
                                              &key (verbose nil) (subject nil))
  (cond
    ((or verbose *history*)
     (unless (equal (string-downcase (send self :name)) "hidden")
             (format stream "~%; ~a: Name:      ~a~%" 
                     (if subject "In    :" "Object") 
                     (send self :proper-name))
             (format stream   ";         StObjType: ~a~%" (send self :vistatype))
             (format stream   ";         ProtoType: ~a~%" 
                     (string-capitalize (send self :slot-value 'proto-name)))
             (format stream   ";         Address:   ~d~%" (address-of self))
             (format stream   ";         Created:   ~a~%" 
                         (send self :slot-value 'instance-info))
             (format stream   ";         Elapsed:   ~,4d seconds~%" 
                     (fuzz (send self :elapsed-time) 3))))
    (t
     (format stream "; Transf: ~a~%> "
             (send self :vistatype))
     (send $ :info)
     t)))


(defmeth transf-object-proto :visualize-transformation ()
  (setf *current-transf* self)
  (setf current-transf self)
  (send *workmap* :stop-screen-saver)
#+containers
  (progn
   (send *watcher* :write-text "Constructing Container Object")
   (setf *spreadplot-container* 
         (make-container :size (send *vista* :spreadplot-sizes) 
                         :free *free-spreadplots*
                         :local-menus *free-spreadplots*
                         :title "visual transf container"
                         :type 7;3
                         :show nil)))
  (send *current-transf* :visualize)
#+containers
  (progn
   (send *watcher* :write-text "Showing Spreadplot")
   (apply #'send *spreadplot-container* :location 
          (send *vista* :workmap-location))
   (apply #'send *spreadplot-container* :size 
          (send *vista* :spreadplot-sizes))
   (refresh-spreadplot)
   (send *spreadplot-container* :show-window) 
   (disable-container)
   )
  )
  


;;------------------------------------------------------------------------
;;transpose-data object proto
;;------------------------------------------------------------------------

(defproto trnsps-transf-object-proto '() () transf-object-proto)

(defmeth trnsps-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth trnsps-transf-object-proto :options () t)

(defmeth trnsps-transf-object-proto :analysis ()
  (let* ((intypes (send current-data :active-types '(all)))
         (intypes (mapcar #'(lambda (str) (string-downcase str))
                          intypes))
         (nobs (send current-data :active-nobs))
         (outtypes)
         (incats? (if (member "category" intypes :test #'equal) t nil))
         (outcats?)

         )
    (when incats? 
          (vista-message "Cannot transpose category variables because array may have too many ways and/or categories.")
          (setf outcats? nil))
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Transposed " (send self :title))
          :variables (send current-data :active-labels) 
          :data      (combine 
                      (transpose (send self :active-data-matrix 
                                       '(numeric ordinal))))
          :freq      (send self :freq)
          :row-label (second (send self :freq-way-names))
          :column-label (first (send self :freq-way-names))
          :about     (send self :about)
          :labels    (send self :active-variables '(numeric ordinal))
          :types     outtypes)
    ))

(defun transpose-data 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Trnsps")
   (title      "Transpose Data")
   )
  (send trnsps-transf-object-proto :new 9 data title name dialog '(all)))

;;------------------------------------------------------------------------
;;standardize-data object proto
;;------------------------------------------------------------------------

(defproto norm-transf-object-proto '(stdv mean) ()
  transf-object-proto)

(defmeth norm-transf-object-proto :isnew (mean stdv &rest args)
  (send self :mean mean)
  (send self :stdv stdv)
  (apply #'call-next-method args))

(defmeth norm-transf-object-proto :stdv (&optional (value nil set))
    (if set (setf (slot-value  'stdv) value))
    (slot-value 'stdv))

(defmeth norm-transf-object-proto :mean (&optional (value nil set))
    (if set (setf (slot-value  'mean) value))
    (slot-value 'mean))

(defmeth norm-transf-object-proto :options ()
  (when (send self :dialog)
        (let ((mean-stdv (send (send self :dialog-box) :modal-dialog))
              )
          (when mean-stdv
                (if (= (select mean-stdv 0) 0)
                    (send self :mean (select mean-stdv 1))
                    (send self :mean nil))
                (if (= (select mean-stdv 2) 0)
                    (send self :stdv (select mean-stdv 3))
                    (send self :stdv nil)))
          mean-stdv)))

(defmeth norm-transf-object-proto :dialog-box ()
  (let* ((var-text (send text-item-proto :new "STANDARDIZE ..."))
         (mean-text (send text-item-proto :new "MEANS:"))
         (mean-item (send choice-item-proto :new
                    (list "Change all to:" "Change none.")))
         (mean-value-item 
          (send edit-text-item-proto :new "0.0" :text-length 3))
         (stdv-text (send text-item-proto :new "STANDARD DEVIATIONS:"))
         (stdv-item (send choice-item-proto :new
                    (list "Change all to:" "Change none.")))
         (stdv-value-item
          (send edit-text-item-proto :new "1.0" :text-length 3))
         (cancel    (send modal-button-proto :new "Cancel"))
         (ok        (send modal-button-proto :new "OK" :action #'(lambda () 
                    (list (send mean-item :value) 
                          (number-from-string (send mean-value-item :text))
                          (send stdv-item :value)
                          (number-from-string (send stdv-value-item :text))
                          )))))
    (send modal-dialog-proto :new
               (list var-text 
                     mean-text 
                     (list mean-item mean-value-item) 
                     stdv-text 
                     (list stdv-item stdv-value-item) 
                     (list ok cancel))
          :default-button ok)
        ))

(defmeth norm-transf-object-proto :analysis  ()
  (let* ((mean (list (send self :mean)))
         (stdv (send self :stdv))
         (data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
         (means (mapcar #' (lambda (x) (list (mean (non-missing x))))
(column-list data-matrix)))
         (ncol (length means))
;; modified by PV to deal with missing data 30.7.98
         (result-matrix nil)
         )
    (setf data-matrix (center data-matrix))
    (when stdv (setf data-matrix (normalize data-matrix stdv)))
    (if mean 
        (setf data-matrix (map-elements #'function-with-missing #'+  
(column-list data-matrix) (repeat (list mean) ncol)))
        (setf data-matrix (map-elements #'function-with-missing #'+  
(column-list data-matrix) means)))
    (setf data-matrix 
               (transpose (matrix size (combine data-matrix))))
    (data (send self :name)
          :created (- (send *desktop* :num-icons) 1)
          :title (concatenate 'string "Standardized " (send self :title))
          :labels (send current-data :active-labels) 
          :data (combine data-matrix)
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :variables (send self :active-variables '(numeric))
          :types     (send self :active-types     '(numeric)))
    ))

(defun standardize-data 
  (&key 
      (data      current-data)
      (mean      0)
      (stdv      1)
      (dialog    nil)
      (name      "Std")
      (title     "Standardize Data")
   )
  (send norm-transf-object-proto :new mean stdv 9 data title name dialog))

;;------------------------------------------------------------------------
;;orthogonalize-data object proto
;;------------------------------------------------------------------------

(defproto orthog-transf-object-proto '() () transf-object-proto)

(defmeth orthog-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth orthog-transf-object-proto :options ()
  t)

(defmeth orthog-transf-object-proto :analysis ()
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Orthogonalized " (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine (second (gs-orthog
                           (send self :active-data-matrix '(numeric)))))
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :variables (send self :active-variables '(numeric))
          :types     (send self :active-types     '(numeric)))
  )

(defun orthogonalize-data 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Orthog")
   (title      "Orthogonalize Data")
   )
  (send orthog-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;correlation object proto
;;------------------------------------------------------------------------

(defproto corr-transf-object-proto '() () transf-object-proto)

(defmeth corr-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth corr-transf-object-proto :options ()
  t)

(defmeth corr-transf-object-proto :analysis ()
  (data (send self :name)
        :created   (- (send *desktop* :num-icons) 1)
        :matrices '("Correlations")
        :shapes   '("symmetric")
        :title     (strcat "Correlations of " (send self :title))
        :labels    (send current-data :active-labels) 
        :data      (combine (correlation-matrix 
                             (send self :active-data-matrix '(numeric))))
        :variables (send self :active-variables '(numeric))
        :types     (send self :active-types     '(numeric)))
  )

(defun correlations 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Corr")
   (title      "Correlation Matrix")
   )
  (send corr-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;covariance object proto
;;------------------------------------------------------------------------

(defproto covar-transf-object-proto '() () transf-object-proto)

(defmeth covar-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth covar-transf-object-proto :options ()
  t)

(defmeth covar-transf-object-proto :analysis ()
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :matrices '("Covariances")
          :shapes   '("symmetric")
          :title     (strcat "Covariances of " (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine (covariance-matrix 
                               (send self :active-data-matrix '(numeric))))
          :variables (send self :active-variables '(numeric))
          :types     (send self :active-types     '(numeric)))
  )

(defun covariances 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Cov")
   (title      "Covariance Matrix")
   )
  (send covar-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;distance object proto
;;------------------------------------------------------------------------

(defproto dist-transf-object-proto '() () transf-object-proto)

(defmeth dist-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth dist-transf-object-proto :options ()
  t)

(defmeth dist-transf-object-proto :analysis ()
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :matrices '("Distances")
          :shapes   '("symmetric")
          :title     (strcat "Distances from " (send self :title))
          :labels    (send self :active-variables '(numeric)) 
          :data      (combine (distance-matrix 
                               (send self :active-data-matrix '(numeric))))
          :variables (send current-data :active-labels)
          :types     (repeat "numeric" (send self :active-nobs))))

(defun distances 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Dist")
   (title      "Distance Matrix")
   )
  (send dist-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;sort object proto
;;------------------------------------------------------------------------

(defproto sort-transf-object-proto '(sort-label sort-var descending) ()
  transf-object-proto)

(defmeth sort-transf-object-proto 
             :isnew (sort-label sort-var descending &rest args)
  (if sort-var 
        (send self :sort-label nil)
        (send self :sort-label sort-label))
  (send self :descending descending)
  (send self :sort-var sort-var)
  (apply #'call-next-method args)
  )

(defmeth sort-transf-object-proto :sort-label (&optional (logical nil set))
    (if set (setf (slot-value  'sort-label) logical))
    (slot-value 'sort-label))

(defmeth sort-transf-object-proto :sort-var (&optional (value nil set))
    (if set (setf (slot-value  'sort-var) value))
    (slot-value 'sort-var))

(defmeth sort-transf-object-proto :descending (&optional (logical nil set))
    (if set (setf (slot-value  'descending) logical))
    (slot-value 'descending))

(defmeth sort-transf-object-proto :options ()
  (when (send self :dialog)
        (let ((result (send (send self :dialog-box) :modal-dialog))
              ) 
          (when result 
                (send self :sort-label (= 0 (first result)))
                (send self :sort-var (second result))
                (send self :descending (third result))) 
          (when (and (not (send self :sort-var)) 
                     (not (send self :sort-label)))
                (error-message 
                 "You must select labels or a variable for sorting."));fwy4.29
          result)))

(defmeth sort-transf-object-proto :dialog-box ()
  (let* ((var-text 
          (send text-item-proto :new "SORT ...    by selected variable"))
         (perm-text 
          (send text-item-proto :new "PERMUTE ... all other variables"))
         (var-item (send choice-item-proto :new
                         (list "Sort by observation labels"
                               "Sort by values of variable:")
                         :value 1)) ;fwy4.28
         (var-list (send current-data :active-variables '(all)))
         (var-list-item (send list-item-proto :new var-list
                              ;:size (list 200 96)
                              
                              ))
         (descending 
          (send toggle-item-proto :new "Sort into descending order"))
         (cancel    (send modal-button-proto :new "Cancel"))
         (ok        (send modal-button-proto :new "OK" :action #'
                          (lambda () 
                            (list (send var-item :value)
                                  (send var-list-item :selection)
                                  (send descending :value)))))
         )
    (send modal-dialog-proto :new
               (list var-text
                     perm-text
                     var-item
                     var-list-item
                     descending
                     (list ok cancel))
          :default-button ok)
    ))

(defmeth sort-transf-object-proto :analysis ()
  (let* ((data-matrix (send self :active-data-matrix '(all)))
         (labels (send current-data :active-labels))
         (rows-of-data-matrix (row-list data-matrix))
         (order-var nil)
         (var nil)
         (permuted-data nil)
         (permuted-labels nil)
         (permuted-data-matrix nil)
         (result nil))
    (when (stringp (send self :sort-var))
          (send self :sort-var 
                (select ($position 
                         (list (send self :sort-var)) 
                         (send self :active-variables '(all))) 0)))
    (if (send self :sort-label)
        (setf var labels)
        (setf var (send self :variable 
                        (select (send self :active-variables '(all)) 
                                (send self :sort-var)))))
    ;; follow modifications by PV to deal with missing data 9.12.98
    (cond
     ((not (= (length var) (length (non-missing var))))
      
      (setf result 
              (sort-and-permute-dob (select data-matrix 
                                        (id-non-missing var) 
                                        (iseq 0 (1- (second (size data-matrix))))) 
                                    (select labels (id-non-missing var)) 
                                    (non-missing var) 
                                    (send self :descending)))
       (setf missing-matrix (select data-matrix 
                                     (set-difference 
                                      (iseq 0 (1- (first (size data-matrix))))
                                      (id-non-missing var))  
                                     (iseq 0 (1- (second (size data-matrix))))))
       (setf labels-missing (select labels 
                                 (set-difference 
                                  (iseq 0 (1- (length labels)))
                                  (id-non-missing var))))
       (setf result (append 
                 (list (bind-rows (first result) missing-matrix)) 
                 (list (combine (second result) labels-missing)) 
                 (list (combine (third result)  
                          (set-difference 
                                  (iseq 0 (1- (length labels)))
                                  (id-non-missing var))))))
                      )
      (t (setf result 
          (sort-and-permute-dob data-matrix labels var 
                                (send self :descending)))
         ))
                                
                                        

    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Sorted " (send self :title))
          :labels    (second result) 
          :data      (combine (first result))
         ; :variables (send self :active-variables '(numeric))
         ; :types     (send self :active-types     '(numeric))
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :variables (send self :variables);fwy4.28
          :types     (send self :types));fwy4.28
    ))

(defun sort-permute
  (&key
   (data current-data)
   (dialog nil)
   (name "Sort")
   (title "Sort-Permute Observations")
   (label t)
   (variable nil)
   (descending nil)
   )
  (let ((ok-types '(all)));fwy4.28
    (send sort-transf-object-proto 
          :new label variable descending 9 data title name dialog  
               ok-types)));fwy4.28

;;------------------------------------------------------------------------
;;rank object proto
;;------------------------------------------------------------------------

(defproto rank-transf-object-proto '() () transf-object-proto)

(defmeth rank-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth rank-transf-object-proto :options ()
  t)

(defmeth rank-transf-object-proto :analysis ()
  (let* (
         (data-matrix 
          (send self :active-data-matrix '(numeric ordinal)));fwy4.28
         (size (reverse (array-dimensions data-matrix)))
         (rank-data 
          (map-elements  #'function-with-missing #'rank-with-ties
(column-list data-matrix)));fwy4.28
         ;; modified by PV to deal with missing data 30.7.98
         (rank-data-matrix (transpose (matrix size (combine rank-data))))
         )
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Ranked " (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine rank-data-matrix)
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :variables (send self :active-variables '(numeric ordinal));fwy4.28
          :types     (send self :active-types     '(numeric ordinal)));fwy4.28
    ))

(defun ranks 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Rank")
   (title      "Rank Data")
   )
  (let ((ok-types '(numeric ordinal)));fwy4.28
    (send rank-transf-object-proto :new 9 data title name dialog
          ok-types)));fwy4.28

(provide "tranobj1")